home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / 6.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  38KB  |  1,256 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #include "hdr.h"
  11. #include "libhdr.h"
  12. #include "vars.h"
  13. #include "setp.h"
  14. #include "dclmapp.h"
  15. #include "errmsgp.h"
  16. #include "miscp.h"
  17. #include "smiscp.h"
  18. #include "nodesp.h"
  19. #include "utilp.h"
  20. #include "chapp.h"
  21. #include "libp.h"
  22.  
  23. static void invisible_designator(Node, char *);
  24. static Tuple derived_formals(Symbol, Tuple);
  25. static void proc_or_entry(Node);
  26. static void new_over_spec(Symbol, int, Symbol, Tuple, Symbol, Node);
  27.  
  28. void subprog_decl(Node node)  /*;subprog_decl*/
  29. {
  30.     Node    spec_node, id_node, neq_node, eq_node;
  31.     Symbol    subp_name, neq;
  32.     int        exists;
  33.     Forset    fs1;
  34.  
  35.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  subprog_decl");
  36.  
  37.     spec_node = N_AST1(node);
  38.     id_node = N_AST1(spec_node);
  39.     new_compunit("ss", id_node);
  40.     adasem(spec_node);
  41.     check_spec(node);
  42.  
  43.     subp_name = N_UNQ(id_node);
  44.     save_subprog_info(subp_name);
  45.  
  46.     /* Modify the node kind for subprogram declarations to be 
  47.      * as_subprogram_decl_tr so that their specification part need not be 
  48.      * saved in the tree automatically. The formal part will be saved by 
  49.      * collect_unit_nodes only in the case of a subprogram specification 
  50.      * that is not in the same unit as the body as it is then needed for 
  51.      * conformance checks. In addition the node as_procedure (as_function)
  52.      * is no longer needed in the tree since this info is obtained from
  53.      * the symbol table.
  54.      * Since the spec  part is now dropped we now move the id_node info 
  55.      * (name of the subprogram) to the N_UNQ filed of the as_subprogram_decl_tr
  56.      * node directly.
  57.      */
  58.  
  59.     N_KIND(node) = as_subprogram_decl_tr;
  60.     N_UNQ(node) = N_UNQ(id_node);
  61.     if (streq(N_VAL(id_node) , "=") &&  tup_size(SIGNATURE(subp_name)) == 2) {
  62.         /* build tree for declaration of inequality that was just introduced 
  63.          * (in the current scope, or the enclosing one, if now in private part).
  64.          */
  65.         exists = FALSE;
  66.         FORSET(neq = (Symbol), OVERLOADS(dcl_get(DECLARED(SCOPE_OF(subp_name)),
  67.           "/=")), fs1);
  68.             if ( same_signature(neq, subp_name) ) {
  69.                 exists = TRUE;
  70.                 break;
  71.             }
  72.         ENDFORSET(fs1);
  73.         if (exists) {
  74.             neq_node = copy_tree(node);          /* a valid subprogram decl*/
  75.             N_UNQ(neq_node) = neq;
  76.             eq_node = copy_node(node);
  77.             make_insert_node(node, tup_new1((char *) eq_node), neq_node);
  78.         }
  79.     }
  80. }
  81.  
  82. void check_spec(Node node) /*;check_spec*/
  83. {
  84.     /* If the subprogram name is an     operator designator, verify that it has
  85.      * the proper type and number of arguments.
  86.      */
  87.  
  88.     int        proc_nat;
  89.     Node    spec_node, id_node, formal_node, ret_node;
  90.     char    *proc_id;
  91.     Tuple    formals;
  92.     Symbol    ret;
  93.     Symbol    prog_name;
  94.     int        spec_kind, node_kind;
  95.  
  96.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  check_spec ");
  97.  
  98.     spec_node = N_AST1(node);
  99.     id_node = N_AST1(spec_node);
  100.     formal_node = N_AST2(spec_node);
  101.     ret_node = N_AST3(spec_node);
  102.     proc_id = N_VAL(id_node);
  103.  
  104.     spec_kind = N_KIND(spec_node);
  105.     if (spec_kind == as_procedure)
  106.         ret = symbol_none;
  107.     else
  108.         ret = N_UNQ(ret_node);
  109.  
  110.     switch (node_kind = N_KIND(node)) {
  111.       case    as_subprogram_decl:
  112.                 if (spec_kind == as_procedure)
  113.                     proc_nat = na_procedure_spec;
  114.                 else
  115.                     proc_nat = na_function_spec;
  116.                 break;
  117.       case    as_subprogram:
  118.       case    as_subprogram_stub:
  119.       case    as_generic_subp:
  120.                 if (spec_kind == as_procedure)
  121.                     proc_nat = na_procedure;
  122.                 else
  123.                     proc_nat = na_function;
  124.                 break;
  125.     }
  126.  
  127.     formals = get_formals(formal_node, proc_id);
  128.  
  129.     check_out_parameters(formals);
  130.  
  131.     if (in_op_designators(proc_id ))
  132.         check_new_op(id_node, formals, ret);
  133.  
  134.     prog_name = chain_overloads(proc_id, proc_nat, ret, formals, (Symbol)0,
  135.       formal_node);
  136.     N_UNQ(id_node) = prog_name;
  137. }
  138.  
  139. void check_new_op(Node id_node, Tuple formals, Symbol ret)    /*;check_new_op */
  140. {
  141.     /* apply special checks for definition of operators */
  142.     char *proc_id;
  143.     Tuple tup;
  144.     Fortup ft1;
  145.     Node  initv;
  146.     int  exists;
  147.     Symbol typ1;
  148.  
  149.     proc_id = N_VAL(id_node);
  150.  
  151.     if ((strcmp(proc_id , "+") == 0 || strcmp(proc_id, "-") == 0)
  152.       && tup_size(formals) == 1)
  153.         ;    /* Unary operators.*/
  154.     else if ( (strcmp(proc_id , "not") == 0 || strcmp(proc_id, "abs") == 0)
  155.       ? tup_size(formals) == 1 : tup_size(formals) == 2 )
  156.         ;
  157.     else {
  158.         errmsg_str("Incorrect no. of arguments for operator %" , proc_id,
  159.           "6.7", id_node);
  160.     }
  161.  
  162.     exists = FALSE;
  163.     FORTUP(tup = (Tuple), formals, ft1);
  164.         initv = (Node)tup[4];
  165.         if (initv != OPT_NODE) {
  166.             exists = TRUE;
  167.             break;
  168.         }
  169.     ENDFORTUP(ft1);
  170.     if (exists) {
  171.         errmsg("Initializations not allowed for operators", "6.7", initv);
  172.     }
  173.     /* Apply the special checks on redefinitions of equality.*/
  174.     else if (streq(proc_id , "=")) {
  175.         typ1 = (Symbol) ((Tuple)formals[1])[3];    /* type of formal*/
  176.         if (tup_size(formals) != 2
  177.           || typ1 != (Symbol) ((Tuple)formals[2])[3] 
  178.           || ret != symbol_boolean) {
  179.             errmsg("Invalid argument profile for \"=\"", "6.7", id_node);
  180.         }
  181.     }
  182.     else if (strcmp(proc_id , "/=") == 0) {
  183.         errmsg(" /=     cannot be given an explicit definition", "6.7", id_node);
  184.     }
  185. } /* end check_new_op */
  186.  
  187. Tuple get_formals(Node formal_list, char *proc_id)             /*;get_formals*/
  188. {
  189.     /* Utility to format the formals of a subprogram specification, in the
  190.      * internal form kept in  the subprogram's signature.
  191.      */
  192.  
  193.     Node    formal_node, id_list, m_node, type_node, exp_node, id_node;
  194.     Tuple    formals, tup;
  195.     Fortup    ft1, ft2;
  196.     int        formal_index, f_mode;
  197.     Symbol     type_mark;
  198.  
  199.     formal_index = 0;
  200.     FORTUP(formal_node = (Node), N_LIST(formal_list), ft1);
  201.         id_list = N_AST1(formal_node);
  202.         FORTUP(id_node = (Node), N_LIST(id_list), ft2);
  203.             formal_index++;
  204.         ENDFORTUP(ft2);
  205.     ENDFORTUP(ft1);
  206.     formals = tup_new(formal_index);
  207.     formal_index = 0;
  208.  
  209.     FORTUP(formal_node = (Node), N_LIST(formal_list), ft1);
  210.         id_list = N_AST1(formal_node);
  211.         m_node = N_AST2(formal_node);
  212.         type_node = N_AST3(formal_node);
  213.         invisible_designator(type_node, proc_id);
  214.         exp_node = N_AST4(formal_node);
  215.         invisible_designator(exp_node, proc_id);
  216.         f_mode = (int) N_VAL(m_node);
  217.         if (f_mode == 0) f_mode = na_in; /* note using 0 for '' f_mode case */
  218.         type_mark = find_type(copy_tree(type_node)); /* for conformance check */
  219.         FORTUP(id_node = (Node), N_LIST(id_list), ft2);
  220.             formal_index++;
  221.             tup = tup_new(4);
  222.             tup[1] = (char *)N_VAL(id_node);
  223.             tup[2] = (char *) f_mode;
  224.             tup[3] = (char *) type_mark;
  225.             tup[4] = (char *) copy_tree(exp_node);
  226.             formals[formal_index] = (char *) tup;
  227.         ENDFORTUP(ft2);
  228.     ENDFORTUP(ft1);
  229.  
  230.     return (formals);
  231. }
  232.  
  233. static void invisible_designator(Node tree_node, char *proc_id)
  234. /*;invisible_designator*/
  235. {
  236.     /*
  237.      * check for premature use of formals
  238.      */
  239.  
  240.     int        nk;
  241.     Node    n;
  242.     Fortup    ft1;
  243.  
  244.     /* The designator of a subprogram is not visible within its specification.*/
  245.  
  246.     nk = N_KIND(tree_node);
  247.     if (N_KIND(tree_node) == as_simple_name)  {
  248.         if (streq(N_VAL(tree_node), proc_id))
  249.             errmsg_str("premature usage of %", proc_id, "8.3(16)", tree_node);
  250.     }
  251.     else {
  252.         if (N_AST1_DEFINED(nk)) invisible_designator(N_AST1(tree_node),proc_id);
  253.         if (N_AST2_DEFINED(nk)) invisible_designator(N_AST2(tree_node),proc_id);
  254.         if (N_AST3_DEFINED(nk)) invisible_designator(N_AST3(tree_node),proc_id);
  255.         if (N_AST4_DEFINED(nk)) invisible_designator(N_AST4(tree_node),proc_id);
  256.  
  257.         if (N_LIST_DEFINED(nk) && N_LIST(tree_node) != (Tuple)0) {
  258.             FORTUP(n = (Node), N_LIST(tree_node), ft1);
  259.                 invisible_designator(n, proc_id);
  260.             ENDFORTUP(ft1);
  261.         }
  262.     }
  263. }
  264.  
  265. void subprog_body(Node node)        /*;subprog_body*/
  266. {
  267.     Node    specs_node, id_node, stats_node;
  268.     Node    eq_node, neq_node;
  269.     char    *spec_name, *prog_id;
  270.     Symbol    unname, prog_name, neq, scope;
  271.     int        i;
  272.     Forset    fs1;
  273.     Fortup    ft1;
  274.     int        exists;
  275.     Tuple    decscopes, decmaps, s_info;
  276.     /* s_info may not be needed     ds 30 jul*/
  277.     Unitdecl    ud;
  278.  
  279.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : subprog_body");
  280.  
  281.     specs_node  = N_AST1(node);
  282.  
  283.     id_node = N_AST1(specs_node);
  284.     adasem(id_node);
  285.     prog_id = N_VAL(id_node);
  286.  
  287.     if (IS_COMP_UNIT) {
  288.         new_compunit("su", id_node);
  289.         /* If the specification of the unit was itself a compilation unit, we
  290.          * will verify that the two specs are conforming. If this is the
  291.          * body to a generic comp. unit, will have to access and update the
  292.          * spec. In both cases see if the spec. is available.
  293.          */
  294.         spec_name = strjoin("ss", prog_id);    /* Already retrieved*/
  295.         ud = unit_decl_get(spec_name);
  296.         if (ud != (Unitdecl)0) {
  297.             /* Unpack declarations and install symbol table of unit.
  298.              * [unname, s_info, decmap] := UNIT_DECL(spec_name);
  299.              */
  300.             unname = ud->ud_unam;
  301.             s_info = ud->ud_symbols;
  302.             decscopes = ud->ud_decscopes;
  303.             decmaps = ud->ud_decmaps;
  304.             /* Must look before putting because name could have been 'with'ed */
  305.             if (dcl_get(DECLARED(symbol_standard0), prog_id) != unname)
  306.                 dcl_put(DECLARED(symbol_standard0), prog_id, unname);
  307.  
  308.             /* (for decls = decmap(scope)) declared(scope) := decls; end; */
  309.             FORTUPI(scope = (Symbol), decscopes, i, ft1);
  310.                 if (decmaps[i] != (char *)0)
  311.                     DECLARED(scope) = dcl_copy((Declaredmap) decmaps[i]);
  312.             ENDFORTUP(ft1);
  313.  
  314.             /* TBSL does s_info need to be retored ?? */
  315.             symtab_restore(s_info);
  316.         }
  317.     }
  318.     check_old(id_node);
  319.     prog_name = N_UNQ(id_node);
  320.     if (prog_name != (Symbol)0 
  321.       &&(NATURE(prog_name) == na_generic_procedure_spec 
  322.       || NATURE(prog_name) == na_generic_function_spec)) {
  323.         generic_subprog_body(prog_name, node);
  324.         return;
  325.     }
  326.     else {
  327.         /* (Re)process subprogram specification.*/
  328.         adasem(specs_node);
  329.         check_spec(node);
  330.         prog_name = N_UNQ(id_node);
  331.         if (NATURE(prog_name) !=na_procedure && NATURE(prog_name) !=na_function)
  332.             /* illegal subprogram name or redeclaration */
  333.             return;
  334.  
  335.         if (IS_COMP_UNIT && ud != (Unitdecl)0 && prog_name != unname) {
  336.             /* Spec. does not match its previous occurrence, or several
  337.              * subprograms with same name are present.
  338.              */
  339.             errmsg("library subprograms cannot be overloaded",
  340.               "10.1(10)", id_node);
  341.             return;
  342.         }
  343.     }
  344.     if (!streq(original_name(prog_name), unit_name_name(unit_name))) {
  345.         /*
  346.         * All types in the current declarative part must be forced before
  347.         * entering a nested scope.
  348.         */
  349.         force_all_types();
  350.     }
  351.     newscope(prog_name);
  352.     process_subprog_body(node, prog_name);
  353.     force_all_types();
  354.     popscope();
  355.     save_subprog_info(prog_name);
  356.     /* Modify the node kind for subprogram bodies to be as_subprogram_tr 
  357.      * so that their specfication part need not be saved in the tree 
  358.      * automatically. The formal part need not be saved for the bodies
  359.      * since all the info is in the symbol table and the conformance checks
  360.      * are done against the formal part saved for the specification if any
  361.      * was given.
  362.      * In addition the node as_procedure (as_function) is no longer needed 
  363.      * in the tree since this info is obtained from the symbol table.
  364.      * Since the spec part is now dropped we now move the id_node info 
  365.      * (name of the subprogram) to the N_UNQ filed of the as_subprogram_tr
  366.      * node directly. In order to put the unique name info in the 
  367.      * as_subprogram_tr node we must shift the stats_node (statement part) 
  368.      * from being N_AST3 to N_AST1 so that we can use the N_UNQ field.
  369.      */
  370.     N_KIND(node) = as_subprogram_tr;
  371.     stats_node = N_AST3(node);
  372.     N_AST1(node) = stats_node;
  373.     N_UNQ(node) = N_UNQ(id_node);
  374.  
  375.     if (streq(prog_id , "=")) {
  376.         exists = FALSE;
  377.         FORSET(neq = (Symbol), OVERLOADS(dcl_get(DECLARED(SCOPE_OF(prog_name))
  378.           , "/=")), fs1);
  379.             if (same_signature(neq, prog_name) ) {
  380.                 exists = TRUE;
  381.                 break;
  382.             }
  383.         ENDFORSET(fs1);
  384.         if (exists) {
  385.             /* create body of corresponding inequality, whose implicit spec.
  386.              * was introduced with the spec. of equality.
  387.              */
  388.             neq_node = new_not_equals(neq, prog_name);
  389.             eq_node  = copy_node(node);
  390.             make_insert_node(node, tup_new1((char *) eq_node), neq_node);
  391.         }
  392.     }
  393. }
  394.  
  395. void process_subprog_body(Node node, Symbol prog_name) /*;process_subprog_body*/
  396. {
  397.     Node    decl_node, stats_node, handler_node;
  398.     int      has_return;
  399.  
  400.     has_return_stk = tup_with(has_return_stk, (char *)FALSE);
  401.  
  402.     decl_node  = N_AST2(node);
  403.     stats_node = N_AST3(node);
  404.     handler_node = N_AST4(node);
  405.  
  406.     lab_init();
  407.     adasem(decl_node);
  408.     adasem(stats_node);
  409.     adasem(handler_node);
  410.     lab_end();            /* Validate goto statements in subprogram*/
  411.  
  412.     has_return = (int) tup_frome(has_return_stk);
  413.  
  414.     if (NATURE(prog_name) == na_function && !has_return)
  415.         errmsg("Missing RETURN statement in function body", "6.5", node);
  416.  
  417.     check_incomplete_decls(prog_name, node);
  418. }
  419.  
  420. Node new_not_equals(Symbol neq, Symbol eq)                /*;new_not_equals*/
  421. {
  422.     /* Build the tree for the body of an implicitly defined inequality op.
  423.      * This is a prime candidate for on-line expansion later on.
  424.      */
  425.  
  426.     Node    node, id_node, arg1, arg2, a1, a2;
  427.     Node    call_node, not_node, ret_node, stat_node;
  428.     Tuple    sig, tup;
  429.  
  430.     node = node_new(as_subprogram_tr);
  431.     sig = SIGNATURE(neq);
  432.     arg1 = (Node) sig[1];
  433.     arg2 = (Node) sig[2];
  434.     a1 = (Node) new_name_node((Symbol) arg1);
  435.     a2 = (Node) new_name_node((Symbol) arg2);
  436.     tup = tup_new(2);
  437.     tup[1] = (char *) a1;
  438.     tup[2] = (char *) a2;
  439.     call_node = new_call_node(eq, tup, symbol_boolean);
  440.     not_node = new_unop_node(symbol_not, call_node, symbol_boolean);
  441.     id_node = new_name_node(neq);
  442.     ret_node = node_new(as_return);
  443.     N_AST1(ret_node) = not_node;    /* return not(arg1 = arg2)*/
  444.     N_AST2(ret_node) = id_node;
  445.     N_AST3(ret_node) = new_number_node(0);        /* from top level */
  446.     /*
  447.  * Note that stat_node is N_AST1 so is because the node is as_subprogram_tr
  448.  * which has the stat_node is N_AST1 instead of N_AST3 as it is for
  449.  * as_subprogram.
  450.  */
  451.     stat_node = new_statements_node(tup_new1((char *) ret_node));
  452.     N_AST1(node) = stat_node;
  453.     N_AST2(node) = OPT_NODE;
  454.     N_UNQ(node) = neq;        /* ignore formals, etc .*/
  455.     N_AST4(node) = OPT_NODE;
  456.  
  457.     return node;
  458. }
  459.  
  460. Tuple process_formals(Symbol scope, Tuple form_list,int newi)
  461.                                                         /*;process_formals*/
  462. {
  463.     /* This     is called to process  formal parameters of a procedure spec. or
  464.      * entry spec.
  465.      * The flag -newi- indicates whether this is the first time the object is
  466.      * seen. For  an entry or  subprogram declaration,  newi is true; for an
  467.      * accept  statement it is  false. For a  subprogram body it  depends on
  468.      * whether a separate specification was provided.
  469.      */
  470.  
  471.     Tuple    new_form_list, t, tup;
  472.     int        in_out, nat;
  473.     Node    opt_init;
  474.     Symbol    type_mark, form_name, f_nam;
  475.     char    *form_id;
  476.     int        i;
  477.     Fortup    ft1, ft2;
  478.     char    *id;
  479.  
  480.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : process_formals");
  481.  
  482.     new_form_list = tup_new(0);
  483.  
  484.     /* Initialize -declared- map for new scope. */
  485.  
  486.     if (DECLARED(scope) == (Declaredmap)0)
  487.         DECLARED(scope) = dcl_new(0);
  488.     newscope(scope);
  489.     nat = NATURE(scope);
  490.     NATURE(scope) = na_void;
  491.     FORTUP(t = (Tuple), form_list, ft1);
  492.         form_id = t[1];
  493.         in_out = (int) t[2];
  494.         type_mark = (Symbol)t[3];
  495.         opt_init = (Node) t[4];
  496.  
  497.         form_name = find_new(form_id);
  498.         /* formals parameters cannot have an incomplete type. They can
  499.          * have an incomplete private type however.
  500.          */
  501.         if (TYPE_OF(type_mark) == symbol_incomplete) {
  502.             errmsg_id("Invalid use of incomplete type %", type_mark,
  503.               "3.8.1", current_node);
  504.         }
  505.         TYPE_OF(form_name) = type_mark;
  506.         default_expr(form_name)  = (Tuple) opt_init;
  507.         if (opt_init != OPT_NODE) {
  508.             adasem(opt_init);
  509.             normalize(type_mark, opt_init);
  510.         }
  511.         ORIG_NAME(form_name) = form_id;
  512.  
  513.         if (opt_init != OPT_NODE && newi && in_out != na_in) {
  514.             errmsg("default initialization only allowed for IN parameters",
  515.               "6.1", current_node);
  516.             opt_init = OPT_NODE;
  517.         }
  518.  
  519.         /* Assignable parameters must not appear in functions.*/
  520.         if ( in_out != na_in && (nat==na_function || nat==na_function_spec )) {
  521.             errmsg_str("functions cannot have % parameters ",
  522.               nature_str(in_out), "6.5", current_node);
  523.         }
  524.  
  525.         TO_XREF(form_name);
  526.         new_form_list = tup_with(new_form_list, (char *) form_name);
  527.     ENDFORTUP(ft1);
  528.     FORTUPI(t = (Tuple), form_list, i, ft1);
  529.         /* at end of formal part, set mode of formal parameters */
  530.         form_id = t[1];
  531.         in_out = (int) t[2];
  532.         form_name = (Symbol) new_form_list[i];
  533.         NATURE(form_name) = in_out;
  534.     ENDFORTUP(ft1);
  535.  
  536.     NATURE(scope) = nat;
  537.     popscope();
  538.     if (newi)
  539.         return new_form_list;
  540.     else {        /* Verify that redeclaration matches. */
  541.         FORTUPI(tup = (Tuple), form_list, i, ft2);
  542.             id= tup[1];
  543.             in_out = (int) tup[2];
  544.             type_mark = (Symbol) tup[3];
  545.             opt_init = (Node) tup[4];
  546.             f_nam = (Symbol) (SIGNATURE(scope))[i];
  547.             if (
  548. #ifdef TBSN
  549.             -- skip this failed since original_name null even though had right
  550.             symbol     ds 1 aug
  551.             strcmp(id, original_name(f_nam)) != 0  ||
  552. #endif
  553.             in_out != NATURE(f_nam) || type_mark != TYPE_OF(f_nam) ) {
  554.                 /* missing conformance on init. */
  555.                 errmsg("Declaration does not match previous specification",
  556.                   "6.3.1", current_node);
  557.             }
  558.         ENDFORTUP(ft2);
  559.         return SIGNATURE(scope);
  560.     }
  561. }
  562.  
  563. static Tuple derived_formals(Symbol scope, Tuple form_list) /*;derived_formals*/
  564. {
  565.     /* build list of formals for derived subprograms.
  566.      * No semantic checks necessary
  567.      */
  568.  
  569.     Tuple new_form_list, t;
  570.     Symbol form_name, type_mark;
  571.     char *form_id;
  572.     int  in_out;
  573.     Node opt_init;
  574.     Fortup ft1;
  575.  
  576.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : derived_formals");
  577.  
  578.     new_form_list = tup_new(0);
  579.  
  580.     /* Initialize -declared- map for new scope. */
  581.     DECLARED(scope) = dcl_new(0);
  582.  
  583.     newscope(scope);
  584.  
  585.     FORTUP(t = (Tuple), form_list, ft1);
  586.         form_id = t[1];
  587.         in_out = (int) t[2];
  588.         type_mark = (Symbol)t[3];
  589.         opt_init = (Node) t[4];
  590.  
  591.         form_name = find_new(form_id);
  592.  
  593.         NATURE(form_name) = in_out;
  594.         TYPE_OF(form_name) = type_mark;
  595.         default_expr(form_name)  = (Tuple) opt_init;
  596.         ORIG_NAME(form_name) = form_id;
  597.  
  598.         new_form_list = tup_with(new_form_list, (char *)form_name);
  599.     ENDFORTUP(ft1);
  600.     popscope();
  601.  
  602.     return(new_form_list);
  603. }
  604.  
  605. void reprocess_formals(Symbol name, Node formals_node)    /*;reprocess_formals */
  606. {
  607.     /* check conformance of subprogram specifications given in spec and body.*/
  608.  
  609.     Node     old_formals_node, old_node, new_node, old_id_list, type_node,
  610.         init_node;
  611.     Symbol     formal, type_mark;
  612.     Tuple    old_list, new_list;
  613.     char    *id;
  614.     int        i;
  615.  
  616.     old_formals_node = (Node) formal_decl_tree(name);
  617.     if (!conform(formals_node, old_formals_node)) {
  618.         conformance_error(formals_node);
  619.         return;
  620.     }
  621.  
  622.     old_list = N_LIST(old_formals_node);
  623.     new_list = N_LIST(formals_node);
  624.     for (i = 1; i <= tup_size(old_list); i++) {
  625.         old_node = (Node) old_list[i];
  626.         new_node = (Node) new_list[i];
  627.         old_id_list = N_AST1(old_node);
  628.         type_node = N_AST3(new_node);
  629.         type_mark = find_type(type_node);
  630.         init_node = N_AST4(new_node);
  631.         id = N_VAL((Node)N_LIST(old_id_list)[1]);
  632.         formal = dcl_get(DECLARED(name), id);
  633.         if (type_mark != TYPE_OF(formal)) {
  634.             conformance_error(type_node);
  635.             return;
  636.         }
  637.         if (init_node != OPT_NODE) {
  638.             adasem(init_node);
  639.             normalize(type_mark, init_node);
  640.         }
  641.         if (!same_expn(init_node, (Node)default_expr(formal))) {
  642.             conformance_error(init_node);
  643.             return;
  644.         }
  645.     }
  646. }
  647.  
  648. void normalize(Symbol context_type, Node expn)                /*;normalize*/
  649. {
  650.     /* This procedure performs type resolution (as in check_type), without
  651.      * constant folding.
  652.      */
  653.  
  654.     Set types, otypes;
  655.     Symbol t, old_context;
  656.     Forset    fs1;
  657.  
  658.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  normalize");
  659.  
  660.     N_TYPE(expn) = symbol_any;        /*By default.*/
  661.     fold_context = FALSE; /* to inhibit constant folding elsewhere.*/
  662.     noop_error = FALSE;
  663.  
  664.     resolve1(expn);        /* Bottom-up pass.*/
  665.  
  666.     if (noop_error) {
  667.         noop_error = FALSE;    /* error emitted already*/
  668.         return;
  669.     }
  670.  
  671.     types = N_PTYPES(expn);
  672.     old_context = context_type;
  673.     if (in_type_classes(context_type)) {
  674.         /* Keep only those that belong to this class.*/
  675.         otypes = set_copy(types);
  676.         types = set_new(0);
  677.         FORSET(t = (Symbol), otypes, fs1);
  678.             if (compatible_types(t, context_type))
  679.                 types = set_with(types, (char *) t);
  680.         ENDFORSET(fs1);
  681.         set_free(otypes);
  682.  
  683.         if (set_size(types) > 1) {
  684.             /* May be overloaded operator: user_defined one hides predefined.*/
  685.             /* types -:= univ_types */
  686.             otypes = set_copy(types); 
  687.             types = set_new(0);
  688.             FORSET(t = (Symbol), otypes, fs1);
  689.                 if (t != symbol_universal_integer && t != symbol_universal_real)
  690.                     types = set_with(types, (char *)t);
  691.             ENDFORSET(fs1);
  692.             set_free(otypes);
  693.         }
  694.  
  695.         if (set_size(types) == 1) {
  696.             context_type = (Symbol) set_arb (types );
  697.             set_free(types);
  698.         }
  699.         else {
  700.             type_error(set_new1((char *) symbol_any), context_type, 
  701.                 set_size(types), expn);
  702.             N_TYPE(expn) = symbol_any;
  703.             set_free(types);
  704.             fold_context = TRUE;
  705.             return;
  706.         }
  707.     }
  708.     resolve2(expn, context_type);
  709.     fold_context = TRUE;
  710.  
  711.     if (noop_error) {
  712.         noop_error = FALSE;    /* error emitted already*/
  713.         return;
  714.     }
  715.     /* Now emit a constraint qualification if needed.*/
  716.     if (! in_type_classes(old_context) ) {
  717.         apply_constraint(expn, context_type);
  718.     }
  719. }
  720.  
  721. int conform(Node exp1, Node exp2)                    /*;conform*/
  722. {
  723.     /* Verify that two trees corresponding to two expressions are conformant,
  724.      * according to 6.2.1. This procedure is called after ascertaining that
  725.      * the trees denote the same entities. We now verify that their lexical
  726.      * structure is conformant.
  727.      */
  728.  
  729.     Tuple    l1, l2;
  730.     Node   sel_node, pfx1, pfx2, sel1, sel2;
  731.     int    i, nk;
  732.     char  * id1;
  733.  
  734.     switch (N_KIND(exp1)) {
  735.     case (as_simple_name):
  736.         if (N_KIND(exp2) == as_simple_name)
  737.             return streq(N_VAL(exp1), N_VAL(exp2));
  738.         else if (N_KIND(exp2) == as_selector) {
  739.             sel_node = N_AST2(exp2);
  740.             id1 = N_VAL(exp1);
  741.             return !in_op_designators(id1) && streq(id1, N_VAL(sel_node));
  742.         }
  743.         else if (N_KIND(exp2) == as_qual_range) {
  744.             /* possible if first occurrence had private type.*/
  745.             return conform(exp1, N_AST1(exp2));
  746.         }
  747.         else
  748.             return FALSE;
  749.     case (as_mode):
  750.         return(N_VAL(exp1) == N_VAL(exp2));   /* mode is integer in C version */
  751.     case (as_int_literal):
  752.         return (N_KIND(exp2) == as_int_literal
  753.           && const_eq(adaval(symbol_universal_integer, N_VAL(exp1)),
  754.           adaval(symbol_universal_integer, N_VAL(exp2)) ));
  755.     case (as_real_literal):
  756.         return (N_KIND(exp2) == as_real_literal
  757.           && const_eq(adaval(symbol_universal_real, N_VAL(exp1)),
  758.           adaval(symbol_universal_real, N_VAL(exp2)) ) );
  759.     case (as_string_literal):
  760.         return(N_KIND(exp2) == as_string_literal
  761.           && streq(N_VAL(exp1), N_VAL(exp2)));
  762.     case (as_selector):
  763.         pfx1 = N_AST1(exp1);
  764.         sel1 = N_AST2(exp1);
  765.         if (N_KIND(exp2) == as_simple_name )
  766.             return (conform(exp2, exp1));
  767.         else if (N_KIND(exp2) == as_selector ) {
  768.             pfx2  = N_AST1(exp2);
  769.             sel2  = N_AST2(exp2);
  770.             return (conform(pfx1, pfx2) && streq(N_VAL(sel1), N_VAL(sel2)));
  771.         }
  772.         else
  773.             return FALSE;
  774.         break;
  775.     default:
  776.         if (N_KIND(exp1) != N_KIND(exp2) )
  777.             return FALSE;
  778.         else {
  779.             /* if is_tuple(a1 := N_AST(exp1)) then 
  780.                *    (for i in [1..#a1])
  781.                 *        if not conform(a1(i), a2(i)) then return FALSE; end;
  782.                *    end for;
  783.                */
  784.             nk = N_KIND(exp1);
  785.             if (N_AST1_DEFINED(nk) && N_AST1(exp1) != (Node)0) {
  786.                 if (!conform(N_AST1(exp1), N_AST1(exp2)))
  787.                     return FALSE;
  788.                 if (N_AST2_DEFINED(nk) && N_AST2(exp1) != (Node)0) {
  789.                     if (!conform(N_AST2(exp1), N_AST2(exp2)))
  790.                         return FALSE;
  791.                     if (N_AST3_DEFINED(nk) && N_AST3(exp1) != (Node)0) {
  792.                         if (!conform(N_AST3(exp1), N_AST3(exp2)))
  793.                             return FALSE;
  794.                         if (N_AST4_DEFINED(nk) &&N_AST4(exp1) != (Node)0) {
  795.                             if (!conform(N_AST4(exp1), N_AST4(exp2)))
  796.                                 return FALSE;
  797.                         }
  798.                     }
  799.                 }
  800.             }
  801.             /* if is_tuple(l1 := N_LIST(exp1)) then
  802.                *    if #l1 != #(l2 := N_LIST(exp2) ? [])) then 
  803.                *        return FALSE;
  804.                *     else
  805.                *       (for i in [1..#l1]))
  806.                *          if not conform(l1(i), l2(i)) then
  807.                *        return FALSE;
  808.                *          end if;
  809.                *    end if;
  810.                * end if;
  811.                  */
  812.             if (N_LIST_DEFINED(nk))
  813.                 l1 = N_LIST(exp1);
  814.             else
  815.                 l1 = (Tuple) 0;
  816.             if (l1 != (Tuple)0) {
  817.                 if (N_LIST_DEFINED(N_KIND(exp2)))
  818.                     l2 = N_LIST(exp2);
  819.                 else
  820.                     l2 = (Tuple) 0;
  821.                 if (l2 == (Tuple)0 || tup_size(l1) != tup_size(l2) )
  822.                     return FALSE;
  823.                 for (i = 1; i <= tup_size(l1); i++) {
  824.                     if (!conform((Node)l1[i], (Node)l2[i]))
  825.                         return FALSE;
  826.                 }
  827.             }
  828.             return TRUE;  /* AST and LIST match. */
  829.         }
  830.     } /* end switch */
  831. }
  832.  
  833. void call_statement(Node node) /*;call_statement*/
  834. {
  835.     /* This procedure resolves call statements. Syntactically the node is
  836.      * a name, possibly selected and indexed.
  837.      * These statements can have one of the following meanings :
  838.      * a) Procedure call.
  839.      * b) entry call .
  840.  
  841.      * Procedure and entry calls are handled by first resolving the name, and
  842.      * then type-checking the  argument list. Complications arise for parame-
  843.      * terless procedures and entries, and for parameterless entries in entry
  844.      * entry  families. In those  cases, this procedure reformats the name by
  845.      * appending an empty argument list.
  846.      */
  847.  
  848.     Node    c_node, arg_list;
  849.     int        nk;
  850.  
  851.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : call_statement");
  852.  
  853.     c_node = N_AST1(node);
  854.     if (N_KIND(c_node) == as_call_unresolved) {
  855.         /* Rebuild call node: proc name, arg_list. */
  856.         /* Next, do N_AST(node) = N_AST(c_node) */
  857.         nk = N_KIND(node);
  858.         if (N_AST1_DEFINED(nk)) N_AST1(node) = N_AST1(c_node);
  859.         if (N_AST2_DEFINED(nk)) N_AST2(node) = N_AST2(c_node);
  860.         if (N_AST3_DEFINED(nk)) N_AST3(node) = N_AST3(c_node);
  861.         if (N_AST4_DEFINED(nk)) N_AST4(node) = N_AST4(c_node);
  862.     }
  863.     else if (N_KIND(c_node) == as_simple_name || N_KIND(c_node)==as_selector) {
  864.         /* Parameterless procedure, */
  865.         /* qualified name of entry.  */
  866.         arg_list = node_new(as_list); /* add empty argument list. */
  867.         N_LIST(arg_list) = tup_new(0);
  868.         N_AST1(node) = c_node;
  869.         N_AST2(node) = arg_list;
  870.     }
  871.     else {
  872.         errmsg("Invalid statement: not procedure or entry call", "5.1", node);
  873.         return;
  874.     }
  875.     proc_or_entry(node);
  876. }
  877.  
  878. static void proc_or_entry(Node node)                    /*;proc_or_entry*/
  879. {
  880.     /* Process procedure calls, entry calls, and calls to members of
  881.      * entry families.
  882.      * The statement :           name(args);
  883.      * can have 3 meanings :
  884.      * a) It can be a procedure call.
  885.      * b) It can be an entry call.
  886.      * c) -name- can be the name of an entry family, and -args- an index
  887.      * into that family. This is recognized by the fact that the type of
  888.      * -name- is an array type.
  889.      * In the first two cases, we must type-check and format the argument
  890.      * list. In the last one, we must emit a parameterless entry call.
  891.  
  892.      * If the statement has the format :    name(arg)(args);
  893.  
  894.      * then it can only be a call  with parameters to an element of an
  895.      * entry family.
  896.      */
  897.  
  898.     Node    obj_node, arg_list, a_node;
  899.     Symbol    obj_name, entr;
  900.     Fortup    ft1;
  901.  
  902.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  proc_or_entry");
  903.  
  904.     obj_node = N_AST1(node);
  905.     arg_list = N_AST2(node);
  906.  
  907.     adasem(obj_node);
  908.     /* Perform name resolution on argument list.*/
  909.     FORTUP(a_node = (Node), N_LIST(arg_list), ft1);
  910.         adasem(a_node);
  911.     ENDFORTUP(ft1);
  912.  
  913.     if (N_KIND(obj_node) == as_simple_name || N_KIND(obj_node) == as_selector) {
  914.         find_old(obj_node);
  915.         obj_name = N_UNQ(obj_node);
  916.  
  917.         /* Probably indicated in a different way */
  918.         if (N_KIND(obj_node) != as_simple_name) {
  919.             entry_call(node);
  920.         }
  921.         else if (obj_name != (Symbol)0  && NATURE(obj_name) == na_entry_family)
  922.             /* entry family called within task body, without qualified name.*/
  923.             entry_call(node);
  924.         else if (N_OVERLOADED(obj_node)) {
  925.             check_type(symbol_none, node);
  926.  
  927.             entr = N_UNQ(obj_node);
  928.             if (entr != (Symbol)0 && NATURE(entr) == na_entry) {
  929.                 Symbol task_name;
  930.                 task_name = SCOPE_OF(entr);
  931.                 if (is_task_type(task_name))
  932.                     task_name = dcl_get(DECLARED(task_name), "current_task");
  933.                 N_KIND(obj_node) = as_entry_name;
  934.                 N_AST1(obj_node) = new_name_node(task_name);
  935.                 N_AST2(obj_node) = new_name_node(entr);
  936.                 N_AST3(obj_node) = OPT_NODE;
  937.             }
  938.             if (N_KIND(node) != as_call && N_KIND(node) != as_ecall) {
  939.                 errmsg("Invalid procedure or entry call", "6.5, 9.5", node);
  940.             }
  941.  
  942.         }
  943.         else {
  944.         /* If the name was undeclared, an error message was emitted
  945.          * already. We can detect this case by the fact that the identifier
  946.          * has type -any-.
  947.          */
  948.             if (TYPE_OF(obj_name) != symbol_any ) {
  949.                 errmsg("Invalid statement", "5.1", node);
  950.             }
  951.             else {
  952.             /* Make up a dummy symbol table entry, so that subsequent uses
  953.              * of it have a chance of looking plausible.
  954.              */
  955.                 NATURE(obj_name) = na_procedure;
  956.                 {    
  957.                     int i, n; 
  958.                     Tuple tup;
  959.                     n = tup_size(N_LIST(arg_list));
  960.                     tup = tup_new(n);
  961.                     for (i = 1; i <= n; i++)
  962.                         tup[i] = (char *) symbol_any_id;
  963.                     SIGNATURE(obj_name) = tup;
  964.                 }
  965.                 TYPE_OF(obj_name) = symbol_none;
  966.                 OVERLOADS(obj_name) = set_new1((char *) obj_name);
  967.             }
  968.         }
  969.     }
  970.     else {
  971.         /* Case of an entry family call with parameters. */
  972.         find_old(obj_node);
  973.         if (N_TYPE(obj_node) == symbol_any || N_KIND(obj_node) != as_index ) {
  974.             errmsg("Invalid call", "9.5", node);
  975.         }
  976.         else entry_call(node);
  977.     }
  978. }
  979.  
  980.  
  981. Symbol chain_overloads(char *id, int new_nat, Symbol new_typ, Tuple new_sig,
  982.   Symbol parent_subp, Node formals_node) /*;chain_overloads*/
  983. {
  984.     /* Insert procedure, function, or enumeration literal into the current
  985.      * symbol table. Because these names can be overloaded, each set of
  986.      * overloaded names visible in the current scope is held in the
  987.      * -overload- attribute of the corresponding identifier.
  988.      * If there is no actual overload, the unique name is generated as for
  989.      * any other identifier. Otherwise, successive overloads in the same
  990.      * scope are given an additional arbitrary suffix to distinguish them
  991.      * one from the other.
  992.      * The overloaded name in inserted in the current scope.
  993.      */
  994.  
  995.     int        old_nat, n;
  996.     Symbol    new_name, seen, name;
  997.     Set        current_overload;
  998.     Forset    fs1;
  999.  
  1000.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  chain_overloads");
  1001.  
  1002.     new_name = sym_new(new_nat);
  1003.  
  1004.     seen = dcl_get(DECLARED(scope_name), id);
  1005.     if (seen== (Symbol)0) {
  1006.         /* First occurrence in this scope. Define therein, and make visible
  1007.          * if scope is visible part of package specification.
  1008.          */
  1009.         dcl_put_vis(DECLARED(scope_name), id, new_name,
  1010.           NATURE(scope_name) == na_package_spec);
  1011.         ORIG_NAME(new_name) = id;
  1012.         new_over_spec(new_name, new_nat, new_typ, new_sig,
  1013.           parent_subp, formals_node);
  1014.     }
  1015.     else {
  1016.         /* Name already appears in current scope. One of the following
  1017.          * may be the case :
  1018.          * a) It is a redeclaration, either because a non-overloaded
  1019.          * instance of that id exists, or because an object with the
  1020.          * same signature has already been declared : indicate error.
  1021.          * b) It is the body of a function or procedure, whose specs
  1022.          * have already been seen. Update the corresponding entry.
  1023.          * c) It is a new object. Generate a new name, and make entry
  1024.          * for it.
  1025.          * d) It is a redeclaration of a derived subprogram. in that case
  1026.          * the derived subprogram becomes inaccessible.
  1027.          * e) If it is a derived subprogram, and there is an explicit user
  1028.          * defined one already, the derived one is discarded. 
  1029.          */
  1030.         if (!can_overload(seen)) {
  1031.             errmsg_str("Redeclaration of identifier %", id, "8.3, 8.4",
  1032.               current_node);
  1033.             return seen;
  1034.         }
  1035.         else {
  1036.             current_overload =  set_copy(OVERLOADS(seen));
  1037.             /* If the current scope is a private part, make sure the visible
  1038.              * declaration has been saved, before any modification of overloads
  1039.              * set.
  1040.              */
  1041.             if ((scope_name != symbol_standard0) &&
  1042.               (NATURE(scope_name) == na_private_part ||
  1043.               NATURE(scope_name) == na_package) &&
  1044.               private_decls_get((Private_declarations)
  1045.               private_decls(scope_name), seen) == (Symbol)0 ) {
  1046.                 private_decls_put((Private_declarations)
  1047.                   private_decls(scope_name), seen);
  1048.             }
  1049.         }
  1050.         FORSET(name = (Symbol), current_overload, fs1);
  1051.             if  (same_sig_spec(name, new_sig)
  1052.               && same_type(TYPE_OF(name), new_typ) ) {
  1053.                 /* A homograph of  the current declaration exists in the
  1054.                  * scope. This is  permissible only if  one or  both are
  1055.                  * implicit declarations of derived subprogram or prede-
  1056.                  * fined operation. The latter  do not appear in Ada/Ed,
  1057.                  * and we only need to consider derived subprograms.
  1058.                  */
  1059.                 if (is_derived_subprogram(name) ) {
  1060.                     /* An explicit declaration redefines an implicitly
  1061.                      * derived subprogram. Make the later unreachable.
  1062.                      */
  1063.                     OVERLOADS(seen) = set_less(OVERLOADS(seen), (char *) name);
  1064.                     /* next line incorrect: code gen. needs to know parent */
  1065.                     /* ALIAS(name) = (Symbol) 0; */
  1066.                 }
  1067.                 else if (parent_subp != (Symbol)0 
  1068.                   && streq(id, ORIG_NAME(parent_subp) )) {
  1069.                     /* New declaration is derived subprogram.*/
  1070.                     new_name = named_atom(id);
  1071.                     if (new_nat != na_literal) {
  1072.                         /* A derived subprogram is hidden by any other homograph
  1073.                          * but may itself be further derived. Insert in symbol
  1074.                          * table as new entity, which is only retrievable when
  1075.                          * iterating over declared map. A derived literal is
  1076.                          * also hidden by other declarations, but still exists
  1077.                          * as a literal of the type. It is inserted in symbol
  1078.                          * table but not in declared. 
  1079.                           */
  1080.                         dcl_put(DECLARED(scope_name), strjoin(id, newat_str()),
  1081.                            new_name);
  1082.                     }
  1083.                     new_over_spec(new_name, new_nat, new_typ, new_sig,
  1084.                       parent_subp, formals_node);
  1085.                     ORIG_NAME(new_name) = id;
  1086.                     return new_name;
  1087.                 }
  1088.                 else {
  1089.                     n = NATURE(name);
  1090.                     if ((n == na_procedure_spec
  1091.                       && new_nat == na_procedure)
  1092.                       || (n == na_function_spec && new_nat == na_function)) {
  1093.                         /* Subprogram body whose spec was already seen.*/
  1094.                         NATURE(name) = new_nat;
  1095.                         /* Verify conformance of formal param declarations.*/
  1096.                         reprocess_formals(name, formals_node);
  1097.                         return name;
  1098.                     }
  1099.                     else {
  1100.                         errmsg_str("invalid declaration of homograph %",
  1101.                           id, "8.3(17)", current_node);
  1102.                         return name;
  1103.                     }
  1104.                 }
  1105.             }
  1106.         ENDFORSET(fs1);
  1107.         /* If we fall through, this is a new entity. Build its symbol table
  1108.          * entry, and add it to the overload set already seen. 
  1109.          * As declared(scope)(id) is already defined, we enter the entity in
  1110.          * the declared map using an arbitrary string. The new entity  will
  1111.          * always be retrieved through overload(seen).
  1112.          * The name of the subprogram becomes hidden until the end of the spec.
  1113.          * In particular, it cannot be used inside the formal part. 
  1114.          */
  1115.         /* add identifier name to result of newat_str to create a unique
  1116.          * anonymous entity which will not conflict with names generated
  1117.          * by anonymous_type
  1118.          */
  1119.         new_name = named_atom(id);
  1120.         dcl_put_vis(DECLARED(scope_name), strjoin(id, newat_str()), new_name,
  1121.           NATURE(scope_name) == na_package_spec);
  1122.         old_nat = NATURE(seen);
  1123.         NATURE(seen) = na_void;
  1124.         new_over_spec(new_name, new_nat, new_typ, new_sig,
  1125.           parent_subp, formals_node);
  1126.         NATURE(seen) = old_nat;
  1127.         OVERLOADS(seen) = set_with(OVERLOADS(seen) , (char *) new_name);
  1128.         ORIG_NAME(new_name) = id;
  1129.     }
  1130.     return new_name;
  1131. }
  1132.  
  1133. int can_overload(Symbol name)  /*;can_overload*/
  1134. {
  1135.     int n;
  1136.     n = NATURE(name);
  1137.     return (n == na_procedure_spec || n == na_function_spec || n == na_op
  1138.       || n == na_function || n == na_procedure || n == na_entry
  1139.       || n == na_literal);
  1140. }
  1141.  
  1142. static void new_over_spec(Symbol name, int nat, Symbol typ, Tuple sig,
  1143.   Symbol parent_subp, Node formals_node) /*;new_over_spec*/
  1144. {
  1145.     /* Place in symbol table maps the specification of a new overloadable
  1146.      * object .
  1147.      */
  1148.  
  1149.     Symbol    arg_type;
  1150.  
  1151.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  new_over_spec");
  1152.  
  1153.     /* Apply the special checks on redefinitions of equality.*/
  1154.  
  1155.     NATURE(name) = nat;
  1156.     TYPE_OF(name) = typ;
  1157.     SCOPE_OF(name) = scope_name;
  1158.     OVERLOADS(name) = set_new1((char *) name);
  1159.     if (nat == na_literal)    SIGNATURE(name) = tup_new(0);
  1160.  
  1161.     /* If the subprograms have the same name but the signatures have different 
  1162.      * types or the subprograms have differing types it is a derived subprogram 
  1163.      * otherwise it is a renaming of a subprogram.
  1164.      */
  1165.     else if (parent_subp != (Symbol) 0 && 
  1166.       streq(ORIG_NAME(name), ORIG_NAME(parent_subp)) &&
  1167.       (!same_sig_spec(parent_subp, sig) || 
  1168.       TYPE_OF(name) != TYPE_OF(parent_subp)))
  1169.         SIGNATURE(name) = derived_formals(name, sig);
  1170.     else {
  1171.         SIGNATURE(name) = process_formals(name, sig, TRUE);
  1172.         formal_decl_tree(name) = (Symbol) formals_node;
  1173.     }
  1174.     if (streq(original_name(name) , "=")) {
  1175.         /* introduce the implicit "/=" as well.*/
  1176.         chain_overloads("/=", na_function, typ, sig, (Symbol)0, OPT_NODE);
  1177.         arg_type = TYPE_OF((Symbol)SIGNATURE(name)[1]);
  1178.         if (!is_limited_type(arg_type) && parent_subp == (Symbol)0) {
  1179.             /* an equality operator can only be defined on limited types
  1180.              * unless it is introduced by a renaming declaration or derivation
  1181.              */
  1182.             errmsg("= can only be defined for limited types", "6.7",
  1183.               current_node);
  1184.         }
  1185.     }
  1186.     TO_XREF(name);
  1187. }
  1188.  
  1189. int same_signature(Symbol sub1, Symbol sub2) /*;same_signature*/
  1190. {
  1191.     /* Compare the signatures of two subprograms to determine whether
  1192.      * they hide each other. Two signatures are considered identical if
  1193.      * they have the same length, and the formals match in name and type.
  1194.      */
  1195.  
  1196.     int        i;
  1197.     Symbol    type1, type2;
  1198.     Tuple    old, newi;
  1199.  
  1200.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  same_signature");
  1201.  
  1202.     old = SIGNATURE(sub1);
  1203.     newi = SIGNATURE(sub2);
  1204.     if (old == newi) return TRUE;
  1205. #ifdef TBSN
  1206.     == how to translate is_tuple ?? ds 8 jun
  1207. else if (! is_tuple(old) ||  ! is_tuple(newi) ) {
  1208.     return FALSE;
  1209. }
  1210. #endif
  1211.     else if (tup_size(old) != tup_size(newi)) return FALSE;
  1212.     else {
  1213.         for (i = 1; i <= tup_size(old); i++) {
  1214.             type1 = (Symbol) old[i]; 
  1215.             type2 = (Symbol) newi[i];
  1216.             if (! same_type(TYPE_OF(type1), TYPE_OF(type2)) ) return FALSE;
  1217.         }
  1218.         return TRUE;
  1219.     }
  1220. }
  1221.  
  1222. int same_sig_spec(Symbol subp, Tuple spec) /*;same_sig_spec*/
  1223. {
  1224.     /* Compare the signature of a subprogram with the formals list of a
  1225.      * new subprogram specification.
  1226.      */
  1227.  
  1228.     Tuple    sig;
  1229.     Tuple    tup;
  1230.     int    i;
  1231.     Symbol    new_typ;
  1232.     Symbol    sym;
  1233.  
  1234.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  same_sig_spec");
  1235.  
  1236.     sig = SIGNATURE(subp);
  1237.  
  1238.     if (tup_size(sig) != tup_size(spec)) return FALSE;
  1239.     else {
  1240.         for (i = 1; i <= tup_size(sig); i++) {
  1241.             tup = (Tuple) spec[i];
  1242.             new_typ = (Symbol)tup[3];
  1243.             sym = (Symbol)(sig[i]);
  1244.             if (!same_type(TYPE_OF(sym), new_typ)) return FALSE;
  1245.         }
  1246.         return TRUE;
  1247.     }
  1248. }
  1249.  
  1250. int same_type(Symbol type1, Symbol type2) /*;same_type*/
  1251. {
  1252.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  same_type");
  1253.  
  1254.     return (base_type(type1) == base_type(type2) );
  1255. }
  1256.